VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form GUIRunner 
   Caption         =   "Form1"
   ClientHeight    =   7170
   ClientLeft      =   27195
   ClientTop       =   1995
   ClientWidth     =   10380
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   ScaleHeight     =   7170
   ScaleWidth      =   10380
   Begin VB.Timer tmrResize 
      Interval        =   50
      Left            =   9240
      Top             =   120
   End
   Begin VB.TextBox txtResult 
      Appearance      =   0  'Flat
      BeginProperty Font 
         Name            =   "Courier New"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   735
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   15
      Text            =   "GUIRunner.frx":0000
      Top             =   4680
      Width           =   8775
   End
   Begin VB.OptionButton optFailed 
      Caption         =   "Failed Only"
      Height          =   255
      Left            =   2640
      TabIndex        =   13
      Top             =   1440
      Width           =   1215
   End
   Begin VB.OptionButton optPassed 
      Caption         =   "Passed Only"
      Height          =   255
      Left            =   1200
      TabIndex        =   12
      Top             =   1440
      Width           =   1215
   End
   Begin VB.OptionButton optFull 
      Caption         =   "Full List"
      Height          =   255
      Left            =   120
      TabIndex        =   11
      Top             =   1440
      Width           =   855
   End
   Begin VB.Frame fraResults 
      Height          =   2175
      Left            =   120
      TabIndex        =   7
      Top             =   1750
      Width           =   8655
      Begin MSComctlLib.TreeView tvResultsFailed 
         Height          =   855
         Left            =   5040
         TabIndex        =   10
         Top             =   240
         Width           =   1695
         _ExtentX        =   2990
         _ExtentY        =   1508
         _Version        =   393217
         Style           =   7
         Appearance      =   1
      End
      Begin MSComctlLib.TreeView tvResultsPassed 
         Height          =   855
         Left            =   2880
         TabIndex        =   9
         Top             =   240
         Width           =   1815
         _ExtentX        =   3201
         _ExtentY        =   1508
         _Version        =   393217
         Style           =   7
         Appearance      =   1
      End
      Begin MSComctlLib.TreeView tvResults 
         Height          =   1215
         Left            =   120
         TabIndex        =   8
         Top             =   240
         Width           =   2295
         _ExtentX        =   4048
         _ExtentY        =   2143
         _Version        =   393217
         LabelEdit       =   1
         Style           =   7
         Appearance      =   1
      End
   End
   Begin VB.Frame fraProgress 
      Height          =   600
      Left            =   120
      TabIndex        =   5
      Top             =   750
      Width           =   2250
      Begin VB.Label lblProgress 
         BackColor       =   &H00FFFFFF&
         Height          =   255
         Left            =   120
         TabIndex        =   6
         Top             =   195
         Width           =   2000
      End
   End
   Begin MSComctlLib.StatusBar sbStatus 
      Align           =   2  'Align Bottom
      Height          =   300
      Left            =   0
      TabIndex        =   0
      Top             =   6870
      Width           =   10380
      _ExtentX        =   18309
      _ExtentY        =   529
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
         NumPanels       =   7
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            AutoSize        =   2
            Object.Width           =   2037
            MinWidth        =   1764
            Text            =   "No. of Classes:"
            TextSave        =   "No. of Classes:"
            Key             =   "Classes"
            Object.ToolTipText     =   "Total number of Test Classes"
         EndProperty
         BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            AutoSize        =   2
            Object.Width           =   2170
            MinWidth        =   1764
            Text            =   "No. of Methods:"
            TextSave        =   "No. of Methods:"
            Key             =   "Methods"
            Object.ToolTipText     =   "Total number of Methods"
         EndProperty
         BeginProperty Panel3 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            AutoSize        =   2
            Object.Width           =   1984
            MinWidth        =   1764
            Text            =   "No. of Asserts:"
            TextSave        =   "No. of Asserts:"
            Key             =   "Asserts"
            Object.ToolTipText     =   "Total number of asserts"
         EndProperty
         BeginProperty Panel4 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Alignment       =   1
            AutoSize        =   1
            Object.Width           =   5336
            MinWidth        =   1764
            Text            =   "Idle"
            TextSave        =   "Idle"
            Key             =   "Status"
            Object.ToolTipText     =   "Current Status"
         EndProperty
         BeginProperty Panel5 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            AutoSize        =   2
            Object.Width           =   2037
            MinWidth        =   1764
            Text            =   "No. of Failures:"
            TextSave        =   "No. of Failures:"
            Key             =   "Failures"
            Object.ToolTipText     =   "Total Number of Test Failures"
         EndProperty
         BeginProperty Panel6 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            AutoSize        =   2
            Object.Width           =   2275
            MinWidth        =   1764
            Text            =   "No. of Warnings:"
            TextSave        =   "No. of Warnings:"
            Key             =   "Warnings"
            Object.ToolTipText     =   "Total Number of Warnings"
         EndProperty
         BeginProperty Panel7 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            AutoSize        =   2
            Object.Width           =   1773
            MinWidth        =   1764
            Text            =   "Secs"
            TextSave        =   "Secs"
            Key             =   "Timer"
            Object.ToolTipText     =   "Test Run Time"
         EndProperty
      EndProperty
      MousePointer    =   7
   End
   Begin VB.Label lblSplit 
      BackColor       =   &H00000000&
      Height          =   70
      Left            =   120
      MousePointer    =   7  'Size N S
      TabIndex        =   14
      Top             =   4560
      Width           =   9855
   End
   Begin VB.Label lblMethod 
      Height          =   195
      Left            =   1080
      TabIndex        =   4
      Top             =   480
      Width           =   7515
   End
   Begin VB.Label lblClass 
      Height          =   195
      Left            =   1080
      TabIndex        =   3
      Top             =   120
      Width           =   7515
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      Caption         =   "Method:"
      Height          =   195
      Left            =   120
      TabIndex        =   2
      Top             =   480
      Width           =   585
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "Class:"
      Height          =   195
      Left            =   120
      TabIndex        =   1
      Top             =   120
      Width           =   420
   End
End
Attribute VB_Name = "GUIRunner"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

'
'Copyright (c) 2010 Andrew Wall
'
' http://www.opensource.org/licenses/mit-license.php
'
'Permission is hereby granted, free of charge, to any person obtaining a copy
'of this software and associated documentation files (the "Software"), to deal
'in the Software without restriction, including without limitation the rights
'to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
'copies of the Software, and to permit persons to whom the Software is
'furnished to do so, subject to the following conditions:
'
'The above copyright notice and this permission notice shall be included in
'all copies or substantial portions of the Software.
'
'THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
'IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
'FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
'AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
'LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
'OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
'THE SOFTWARE.
'

Option Explicit

Public Enum RunnerState
    Undecided
    Warning
    Failed
    Passed
End Enum

Private mState As RunnerState

Private mMargin As Integer

Private mMethodTotal As Long
Private mMethodCount As Long
Private mTotalAssertCount As Long
Private mFailedCount As Long
Private mWarningCount As Long
Private mEquals As New Equality

Private mClass As ClassFixture
Private mClassAssertCount As Integer
Private mClassAssertFailed As Boolean
Private mMethod As MethodFixture
Private mMethodName As String
Private mFineMethod As FineMethodCaller
Private mFineMethodName As String
Private mResultIndex As Integer

Private mResults As New Dictionary

Private mDragging As Boolean
Private mPercentage As Double


Public Sub StartProject(project As ProjectFixture)
Caption = project.name
fraResults.Caption = project.name
SetNumClasses project.numOfClasses
SetNumMethods project.numOfMethods
mMethodTotal = project.numOfMethods
mMethodCount = 0
SetPanelText aPanel("Status"), "Running"
'Allow the timer to fire once
DoEvents
End Sub
Public Sub EndProject(num As Long, Total As Double)
lblClass.Caption = ""
lblMethod.Caption = ""
SetNumAssertions mTotalAssertCount
SetTotalTime Total
Select Case mState
Case Undecided
    lblProgress.BackColor = &HFF00&
    mState = Passed
End Select
Select Case mState
Case Passed
    SetPanelText aPanel("Status"), "Complete"
Case Failed
    SetPanelText aPanel("Status"), "Failed"
Case Warning
    SetPanelText aPanel("Status"), "Warning"
End Select
SetPanelNum "Failures", mFailedCount
SetPanelNum "Warnings", mWarningCount

End Sub
Public Sub ShowModal()
ShowFirstNode
Show
Do
    Sleep 10
    DoEvents
Loop Until Not Visible
End Sub
Private Sub ShowFirstNode()
On Error Resume Next
Dim tv As TreeView
If optFull.value Then
    Set tv = tvResults
ElseIf optPassed.value Then
    Set tv = tvResultsPassed
Else
    Set tv = tvResultsFailed
End If
NodeClick tv.Nodes(1)
End Sub
Public Sub StartClass(Class As ClassFixture)
Set mClass = Class
mClassAssertCount = 0
mClassAssertFailed = False
lblClass.Caption = Class.name
lblMethod.Caption = ""

makeRootNode tvResults, mClass.name
End Sub
Public Sub StartMethod(method As MethodFixture)
Set mMethod = method
lblMethod.Caption = mMethod.name
mMethodCount = mMethodCount + 1
setProgress
mMethodName = mClass.name + "." + mMethod.name
makeNode tvResults, mClass.name, mMethodName, mMethod.name
End Sub

Public Sub StartFineMethod(method As FineMethodCaller)
Set mFineMethod = method
mFineMethodName = mMethodName + "." + method.name
makeNode tvResults, mMethodName, mFineMethodName, method.name
mResultIndex = 0
End Sub
Public Sub EndFineMethod()
Dim info As ErrorInformation
Set info = mFineMethod.errorInfo
If info.number And info.number <> 1001 Then
    addUncaught info
    mClassAssertFailed = True
    Select Case mState
    Case Undecided, Warning
        lblProgress.BackColor = vbRed
        mState = Failed
    End Select
End If

End Sub

Public Sub EndClass()
'Compare asserts with number for class
If Not mClassAssertFailed And mClass.NumOfAsserts > 0 And mClass.NumOfAsserts <> mClassAssertCount Then
    mWarningCount = mWarningCount + 1
    mEquals.equals mClassAssertCount, mClass.NumOfAsserts
    addMismatch mClassAssertCount, mClass.NumOfAsserts, "Assert Mismatch Warning", mEquals.message
    Select Case mState
    Case Undecided
        lblProgress.BackColor = vbYellow
        mState = Warning
    End Select
End If
End Sub

Public Sub testResult(result As Boolean, actual As Variant, expected As Variant, tagMessage As String, fullDescription As String)
Dim color As Long
mTotalAssertCount = mTotalAssertCount + 1
mClassAssertCount = mClassAssertCount + 1
If Not result Then mClassAssertFailed = True

If result Then
    color = vbGreen
Else
    'Use a pale red for readability
    color = &H606000 + vbRed
End If
If Not result Then
    mFailedCount = mFailedCount + 1
End If

addFullResult result, actual, expected, tagMessage, fullDescription, color

Select Case mState
Case Undecided, Warning
    If Not result Then
        lblProgress.BackColor = vbRed
        mState = Failed
    End If
End Select
'Select Case mState
'Case Failed
'    SetPanelNum "Failures", mFailedCount
'End Select
End Sub
Private Sub addFullResult(result As Boolean, actual As Variant, expected As Variant, tagMessage As String, fullDescription As String, color As Long)
Dim res As New ResultItem

mResultIndex = mResultIndex + 1

If Len(tagMessage) Then res.lines.add tagMessage
addStringToCollection fullDescription, res.lines
res.tag = tagMessage
If Len(res.tag) = 0 Then
    res.tag = CStr(mResultIndex)
End If
res.key = mFineMethodName + "." + CStr(mResultIndex)
res.color = color
mResults.add res.key, res

Dim n As Node
Set n = makeNode(tvResults, mFineMethodName, res.key, res.tag)
n.BackColor = res.color
If result Then
    makeParent tvResultsPassed, n.parent
    makeNode(tvResultsPassed, mFineMethodName, res.key, res.tag).BackColor = res.color
Else
    makeParent tvResultsFailed, n.parent
    makeNode(tvResultsFailed, mFineMethodName, res.key, res.tag).BackColor = res.color
End If
End Sub
Private Sub addMismatch(actual As Integer, expected As Integer, tagMessage As String, fullDescription As String)
Dim res As New ResultItem
If Len(tagMessage) Then res.lines.add tagMessage
addStringToCollection fullDescription, res.lines
res.tag = tagMessage
res.key = mClass.name + ".Mismatch"
res.color = vbYellow
mResults.add res.key, res

Dim n As Node
Set n = makeNode(tvResults, mClass.name, res.key, res.tag)
n.BackColor = res.color
makeParent tvResultsFailed, n.parent
makeNode(tvResultsFailed, mClass.name, res.key, res.tag).BackColor = res.color
End Sub
Private Sub addUncaught(info As ErrorInformation)
Dim res As New ResultItem
res.lines.add info.Source
res.lines.add info.name
res.lines.add "Error" + str(info.number) + ":" + info.Description
res.tag = info.Description
res.key = mFineMethodName + ".Error"
res.color = &H707000 + vbRed
mResults.add res.key, res
Dim n As Node
Set n = makeNode(tvResults, mFineMethodName, res.key, res.tag)
n.BackColor = res.color
makeParent tvResultsFailed, n.parent
makeNode(tvResultsFailed, mFineMethodName, res.key, res.tag).BackColor = res.color
End Sub
Private Function addStringToCollection(Description As String, coll As Collection)
Dim desc() As String
Dim i As Integer
desc = Split(Description, vbCrLf)
For i = 0 To UBound(desc)
    If Len(desc(i)) Then coll.add desc(i)
Next
End Function

'Ensure that tree has nodes which have parents up to the root, just like the parent parameter
Private Function makeParent(tree As TreeView, parent As Node) As Node
Dim grandParent As Node
On Error Resume Next
Set makeParent = tree.Nodes.item(parent.key)
If makeParent Is Nothing Then
    Set grandParent = parent.parent
    If grandParent Is Nothing Then
        'Top level node being added
        makeRootNode tree, parent.key
    Else
        makeParent tree, grandParent
        'Add parent as a child of grandparent
        makeNode tree, grandParent.key, parent.key, parent.text
    End If
End If
End Function
Private Function makeRootNode(tree As TreeView, key As String) As Node
Set makeRootNode = tree.Nodes.add(, , key, key)
makeRootNode.Expanded = True
End Function
Private Function makeNode(tree As TreeView, parent As String, key As String, name As String) As Node
Set makeNode = tree.Nodes.add(parent, tvwChild, key, name)
makeNode.Expanded = True
End Function

Private Sub setProgress()
Dim num As Double
If mMethodTotal > 0 Then
    num = Int(fraProgress.width) - lblProgress.Left - 200
    num = num * mMethodCount / mMethodTotal
    lblProgress.width = num
End If
End Sub
Private Property Get aPanel(key As String) As Panel
Set aPanel = sbStatus.Panels.item(key)
End Property
Private Sub SetPanelPost(pan As Panel, postfix As String)
pan.text = pan.text + postfix + "  "
End Sub
Private Sub SetPanelPrefix(pan As Panel, prefix As String)
pan.text = prefix + pan.text + "  "
End Sub
Private Sub SetPanelText(pan As Panel, text As String)
pan.text = text + "  "
End Sub

Private Sub SetPanelNum(key As String, num As Long)
SetPanelPost aPanel(key), str(num)
End Sub
Public Sub SetNumAssertions(num As Long)
SetPanelNum "Asserts", num
End Sub
Public Sub SetNumClasses(num As Long)
SetPanelNum "Classes", num
End Sub
Public Sub SetNumMethods(num As Long)
SetPanelNum "Methods", num
End Sub
Public Sub SetNumWarnings(num As Long)
SetPanelNum "Warnings", num
End Sub
Public Sub SetNumFailures(num As Long)
SetPanelNum "Failures", num
End Sub
Public Sub SetTotalTime(Total As Double)
SetPanelPrefix aPanel("Timer"), Format(Total, "##0.000 ")
End Sub


Private Sub AlignAtLeftOf(C As Control, Fixed As Control)
C.Move Fixed.Left
End Sub
Private Sub RightAlign(C As Control)
C.Left = ScaleWidth - C.width
End Sub
Private Sub Justify(C As Control)
C.width = ScaleWidth - C.Left * 2
End Sub
Private Sub VJustifyBetween(C As Control, FixedUpper As Control, FixedLower As Control)
On Error Resume Next
Dim lower As Integer
Dim newtop As Integer
lower = FixedUpper.Top + FixedUpper.Height
newtop = lower + mMargin
C.Move C.Left, newtop, C.width, FixedLower.Top - newtop - mMargin
End Sub
Private Sub JustifyFrame(C As Control)
C.width = ScaleWidth - C.Left - 70
End Sub
Private Sub SetWithin(C As Control, Outer As Control)
On Error Resume Next
C.Move C.Left, C.Top, Outer.width - 140 - C.Left, Outer.Height - 140 - C.Top
End Sub
Private Sub SetPositionPercentage(C As Control, FixedUpper As Control, FixedLower As Control, perc As Double)
Dim size As Integer
size = FixedLower.Top - FixedUpper.Top
C.Top = size * perc + FixedUpper.Top
End Sub


Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = 27 Then Hide
End Sub

Private Sub Form_Load()
SetPanelText aPanel("Status"), "Idle"
tvResultsFailed.Visible = False
tvResultsPassed.Visible = False
AlignAtLeftOf tvResultsPassed, tvResults
AlignAtLeftOf tvResultsFailed, tvResults
optFailed.value = True
mMargin = fraResults.Top - (optFull.Top + optFull.Height)
mPercentage = 0.5
mState = Undecided

End Sub

Private Sub Form_Paint()
tmrResize.Enabled = True
End Sub
Private Sub Form_Resize()
tmrResize.Enabled = True
End Sub

Private Sub Resize()
JustifyFrame fraProgress
setProgress
JustifyFrame fraResults
Justify lblSplit
SetPositionPercentage lblSplit, fraResults, sbStatus, mPercentage

VJustifyBetween fraResults, optFull, lblSplit

SetWithin tvResults, fraResults
SetWithin tvResultsPassed, fraResults
SetWithin tvResultsFailed, fraResults

Justify txtResult
VJustifyBetween txtResult, lblSplit, sbStatus

End Sub

Private Sub showTrees()
tvResults.Visible = False
tvResultsPassed.Visible = False
tvResultsFailed.Visible = False
If optFull.value Then
    tvResults.Visible = True
ElseIf optPassed.value Then
    tvResultsPassed.Visible = True
Else
    tvResultsFailed.Visible = True
End If
End Sub
Private Sub NodeClick(ByVal Node As MSComctlLib.Node)
Dim keys() As String
keys = Split(Node.key + "..", ".")
If UBound(keys) >= 0 Then lblClass.Caption = keys(0)
If UBound(keys) >= 1 Then lblMethod.Caption = keys(1)
If mResults.Exists(Node.key) Then
    showResultText Node
Else
    txtResult.text = showResults(Node.child)
End If
End Sub
Private Function showResults(ByVal Node As MSComctlLib.Node) As String
Dim aChild As MSComctlLib.Node
Dim text As String
Set aChild = Node
Do While Not aChild Is Nothing
    If mResults.Exists(aChild.key) Then
        text = text + resultText(aChild)
    Else
        text = text + showResults(aChild.child)
    End If
    Set aChild = aChild.Next
Loop
showResults = text
End Function
Private Function resultText(ByVal Node As MSComctlLib.Node) As String
Dim res As ResultItem
Dim item As Variant
Dim text As String
Set res = mResults.item(Node.key)
text = text + Node.parent.text + vbCrLf
For Each item In res.lines
    text = text + "  " + CStr(item) + vbCrLf
Next
resultText = text
End Function
Private Sub showResultText(ByVal Node As MSComctlLib.Node)
Dim res As ResultItem
Dim item As Variant
Dim text As String
Set res = mResults.item(Node.key)
For Each item In res.lines
    text = text + CStr(item) + vbCrLf
Next
txtResult.text = text
End Sub

Private Sub lblSplit_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
mDragging = True
End Sub

Private Sub lblSplit_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If mDragging Then
    lblSplit.Top = lblSplit.Top + Y
    RecalcPercentage
    Resize
End If
End Sub
Private Sub RecalcPercentage()
Dim guess As Double
guess = 0.5
On Error GoTo handle
guess = sbStatus.Top - fraResults.Top
guess = (lblSplit.Top - fraResults.Top) / guess
If (guess > 0.1) And (guess < 0.9) Then
    mPercentage = guess
End If
handle:
Exit Sub
End Sub
Private Sub lblSplit_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
mDragging = False
End Sub

Private Sub optFailed_Click()
showTrees
End Sub

Private Sub optFull_Click()
showTrees
End Sub

Private Sub optPassed_Click()
showTrees
End Sub

Private Sub tmrResize_Timer()
tmrResize.Enabled = False
Resize
End Sub

Private Sub tvResults_BeforeLabelEdit(Cancel As Integer)
Cancel = 1
End Sub

Private Sub tvResults_NodeClick(ByVal Node As MSComctlLib.Node)
NodeClick Node
End Sub

Private Sub tvResultsFailed_BeforeLabelEdit(Cancel As Integer)
Cancel = 1
End Sub

Private Sub tvResultsFailed_NodeClick(ByVal Node As MSComctlLib.Node)
NodeClick Node
End Sub

Private Sub tvResultsPassed_BeforeLabelEdit(Cancel As Integer)
Cancel = 1
End Sub

Private Sub tvResultsPassed_NodeClick(ByVal Node As MSComctlLib.Node)
NodeClick Node
End Sub

Private Sub txtResult_KeyPress(KeyAscii As Integer)
KeyAscii = 0
End Sub
